;;; (load (compile-file #p"c:/documents and settings/shawn betts/my documents/work/l2/test-model.lisp"))

(defpackage #:test-model
  (:use :cl)
  (:export
   #:test-propagate
   #:test-scanner-day-1
   #:test-selection
   #:test-execution))
(in-package :test-model)

;;; pattern matching code. FIXME: Probably at least slightly buggy.

(defun find-matches (pattern tree)
  (labels ((check-first-letter (p i)
             (or (string= (symbol-name p) "?")
                 (char= (char (symbol-name p) 0)
                        (char (symbol-name i) 0))))
           (check-id (p i)
             (or (eql (length (symbol-name p)) 1)
                 (string= (subseq (symbol-name p) 1)
                          (subseq (symbol-name i) 1))))
           (constants-equal (p i)
             (equal p i)))
    (loop for i in tree
       when (and (eql (length i) (length pattern))
                 (every #'check-first-letter pattern i)
                 (every #'check-id pattern i))
       collect i)))

(defun translate-search (p bindings)
  (mapcar (lambda (i)
            (cond
              ((or (numberp i)
                   (find i '(+ - * /))
                   (string= (symbol-name i) "?"))
               i)
              ((find i bindings :key 'first)
               (second (find i bindings :key 'first)))
              (t
               (intern (subseq (symbol-name i) 0 1) :keyword))))
          p))

(defun check-new-bindings (bindings p match)
  (every (lambda (i m)
           (let ((existing (find m bindings :key 'second)))
             ;;(print `(check ,bindings ,i ,m ,existing))
             (or (not existing)
                 (eq i (first existing)))))
         p
         match))

(defun add-bindings (bindings p match)
  (loop
     for i in p
     for m in match
     when (and (symbolp i)
               (> (length (symbol-name i)) 1))
     do (pushnew (list i m) bindings :key 'first))
  bindings)

(defun match-pattern (pattern tree &optional bindings)
  "Return all possibles matches for PATTERN in TREE.

PATTERN is a list of objects. Each object is a list of one or more
elements. Example of objects:
;; Match any empty tile 
\(T)
;; Match an empty tile
\(T1)
;; Match any object with one element
\(?)
;; Match any box that has one tile
\(B T)
;; Match any box with 3 elements
\(B ? ? ?)

Examples of patterns:
;; Match any box with one tile whose value is 5
\(B T1) (T1 5)
;; Match a box that has 3 tiles in it and points to an empty tile
\(B1 ? ? ?) (A B1 T)"
  (if pattern
      (let* ((p (first pattern))
             (matches (find-matches (translate-search p bindings) tree)))
        (loop for m in matches
           when (check-new-bindings bindings p m)
           append (loop for r in (match-pattern (cdr pattern) tree (add-bindings bindings p m))
                     collect (cons m r))))
      `(())))

;;;; Solving Propagate problems 

(defun symbol-to-node-id (sym)
  "Strip off the first letter and turn it into a number to be used in
action command."
  (parse-integer (subseq (symbol-name sym) 1)))

(defun fill-input (answer)
  "Search the tree for the single blue input tile and fill it with
the specified answer."
  (let ((i (first (match-pattern '((i)) (get-diagram)))))
    (assert i)
    (let ((node (symbol-to-node-id (caar i))))
      ;;(m:execute 'enter :node node)
      (m:execute 'keypad-input :value answer)
      (m:execute 'popup-keypad :motion (list :leave node))
      (m:execute 'close-keypad)
      ;;(sleep .01)
      )))

(defun get-diagram ()
  "Return the tree diagram from DUMP-SCREEN."
  (getf (getf (m:dump-screen) :objects) :diagram))

(defun propagate-down-1 ()
  "The evaluate rule. Search for a box with two numbers and an
operator that points to an empty tile. Once found, calculate the
value of the empty tile and fill it in."
  (let ((m (first (match-pattern '((b1 t1 ? t2) (t1 ?) (t2 ?) (a b1 t3) (t3))
                                 (get-diagram)))))
    (when m
      (m:execute 'propagate
                 :id (symbol-to-node-id (first (fifth m))))
      (fill-input (prin1-to-string
                     (funcall (third (first m))
                              (second (second m))
                              (second (third m)))))
      t)))

(defun propagate-down-2 ()
  "The copy down rule. Search for a box with a single number in it
that points to an empty tile. Fill that empty tile with the value
in the box above."
  (let ((m (first (match-pattern '((b1 t1) (t1 ?) (a b1 t3) (t3))
                                 (get-diagram)))))
    (when m
      (m:execute 'propagate
                 :id (symbol-to-node-id (first (fourth m))))
      (fill-input (prin1-to-string (second (second m))))
      t)))

(defun propagate-up-1 ()
  "Search for a box with one number, an operator and an empty
tile. That box must point to a tile with a number. Figure out the
value of the empty tile and fill it in."
  (let ((m (first (match-pattern '((b1 t1 ? t2) (t1) (t2 ?) (a b1 t3) (t3 ?)) (get-diagram)))))
    (when m
      (m:execute 'propagate
                 :id (symbol-to-node-id (first (second m))))
      (fill-input (prin1-to-string
                     (funcall (ecase (third (first m))
                                (+ '-)
                                (- '+)
                                (* '/)
                                (/ '*))
                              (second (fifth m))
                              (second (third m)))))
      t)))

(defun propagate-up-2 ()
  "The same as propagate-up-1 but the empty tile is on the left, not the right."
  (let ((m (first (match-pattern '((b1 t1 ? t2) (t1 ?) (t2) (a b1 t3) (t3 ?)) (get-diagram)))))
    (when m
      (m:execute 'propagate
                 :id (symbol-to-node-id (first (third m))))
      (fill-input (prin1-to-string
                     (ecase (third (first m))
                       ((+ *)
                        (funcall (ecase (third (first m))
                                   (+ '-) (* '/))
                                 (second (fifth m))
                                 (second (second m))))
                       ((- /)
                        (funcall (third (first m))
                                 (second (second m))
                                 (second (fifth m)))))))
      t)))

(defun propagate-up-3 ()
  "The copy up rule. Find a box with a single empty tile. That box
points to a tile with a number. Fill the empty tile with that number. "
  (let ((m (first (match-pattern '((b1 t1) (t1) (a b1 t3) (t3 ?)) (get-diagram)))))
    (when m
      (m:execute 'propagate
                 :id (symbol-to-node-id (first (second m))))
      (fill-input (prin1-to-string (second (fourth m))))
      t)))

;;; Solving a simple Linearize problem

(defun fill-input-boxes (unknown constant)
  "Given the two tiles that linearize creates, fill them with
numbers."
  (let ((m (first (match-pattern '((b1 i1 * t1) (t1) (a b1 t2)
                                   (b2 i2 + t2) (t2))
                                 (get-diagram)))))
    (assert m)
    (let ((c-input (symbol-to-node-id (second (fourth m))))
          (u-input (symbol-to-node-id (second (first m)))))
      ;;(print `(ff ,unknown ,constant))
      (m:execute 'popup-keypad :motion (list :enter c-input))
      (m:execute 'keypad-input :value constant)
      (m:execute 'popup-keypad :motion (list :leave c-input :enter u-input))
      (m:execute 'keypad-input :value unknown)
      (m:execute 'popup-keypad :motion (list :leave u-input))
      (m:execute 'close-keypad)
      ;;(sleep .3)
      )))

(defun linearize-1 ()
  "Just a simple Linearize pattern that happens to work on the first
problem in Day 1. Match the boxes, figure out the values for the
unknown and constant blue boxes and fill them in."
  (let ((m (first (match-pattern '((b1 t1 + t2) (t1) (t2) 
                                   (b2 t3 ? t4) (t3) (t4 ?) (a b2 t2)
                                   (b3 t5) (a b3 t1) (a b3 t3))
                                 (get-diagram)))))
    (when m
      (m:execute 'toggle-selection :id (symbol-to-node-id (first (first m))))
      (m:execute 'toggle-selection :id (symbol-to-node-id (first (fourth m))))
      (m:execute 'linearize)
      (if (eq (third (fifth m)) '*)
          (fill-input-boxes (prin1-to-string (1+ (second (sixth m))))
                            "0")
          (fill-input-boxes "2"
                            (prin1-to-string (funcall (third (fourth m))
                                                      (second (sixth m))))))
      t)))

;;; Completing linearize session
  
(defun skip-the-nback ()
  "Skip through the nback as fast as possible."
  (assert (string= (getf (m:dump-screen) :state) 'nback) ()
          "Current state is not an nback.")
  (loop while (string= (getf (m:dump-screen) :state) 'nback)
        do (m:execute 'next-state)))

(defun solve-problem ()
  "The functions return T when they worked so just try each one until
one works and repeat. When none work, we can assume that the problem
is finished so click Next Problem."
  (loop while (or (propagate-down-1)
                  (propagate-down-2)
                  (propagate-up-1)
                  (propagate-up-2)
                  (propagate-up-3)
                  (linearize-1)))
  (m:execute 'next-problem))

(defun test-propagate ()
  "Walk through to the end of the first problem of the Day 1 Scanner
session."
  (m:start-session 1 "Day 1 Propagate")
  (m:execute 'add-click-message)
  (m:execute 'onward)
  (m:execute 'add-click-message)
  (m:execute 'onward)
  (m:execute 'add-click-message)
  (m:execute 'onward)
  ;; demo
  (dotimes (i 10)
    (model:execute 'forward))
  ;; message
  (m:execute 'add-click-message)
  (m:execute 'onward)
  ;; guided problem
  (solve-problem)
  ;; message
  (m:execute 'add-click-message)
  (m:execute 'onward)
  ;; message about nback
  (m:execute 'add-click-message)
  (m:execute 'onward)
  (m:execute 'onward)
  (skip-the-nback)
  (dotimes (i 20)
    (m:execute 'onward)
    (solve-problem)
    (m:execute 'onward)
    (skip-the-nback))
  (m:execute 'onward))

(defun test-scanner-day-1 ()
  "Walk through to the end of the first problem of the Day 1 Scanner
session."
  (m:start-session 1 "Day 1 Scanner")
  (m:execute 'add-click-message)
  (m:execute 'onward)
  (m:execute 'onward)
  (m:execute 'count-pulses)
  (m:execute 'onward)
  (skip-the-nback)
  (m:execute 'onward)
  (solve-problem))

;;; Selection Task

(defun get-selection-tree ()
  (getf (getf (m:dump-screen) :objects) :tree))

(defun select-boxes ()
  "Given a selection problem, select some random boxes, click submit,
and skip the feedback."
  (let* ((tree (get-selection-tree))
         (boxes (match-pattern '((B T1 ? T2)) tree)))
    ;; Fake it. Just select and unselect a bunch of random ones.
    (dotimes (i 10)
      (m:execute 'selection-click :id (symbol-to-node-id (caar (nth (random (length boxes)) boxes)))))
    (m:execute 'submit-answer)
    ;; skip the feedback quickly
    (m:execute 'feedback-timeout)))

(defun test-selection ()
  "Run through the entire selection section."
  (m:start-session 1 "Day 2 Selection")
  (m:execute 'add-click-message)
  (m:execute 'onward)
  (dotimes (i 24)
    (select-boxes)))

;;; Execution task

(defun get-fill-tree ()
  (getf (getf (m:dump-screen) :objects) :right-tree))

(defun execution-fill ()
  "Given the two blue tiles, fill them with random values and skip the
feedback."
  (let* ((tree (get-fill-tree))
         (tiles (first (match-pattern '((I1) (I2)) tree))))
    ;; Fake it. Just select and unselect a bunch of random ones.
    ;;(print tiles)
    (m:execute 'popup-keypad :motion `(:enter ,(symbol-to-node-id (caar tiles))))
    (m:execute 'keypad-input :value (prin1-to-string (- (random 100) 50)))
    (m:execute 'popup-keypad :motion `(:leave ,(symbol-to-node-id (caar tiles))
                                       :enter ,(symbol-to-node-id (first (second tiles)))))
    (m:execute 'keypad-input :value (prin1-to-string (- (random 100) 50)))
    (m:execute 'popup-keypad :motion `(:leave ,(symbol-to-node-id (first (second tiles)))))
    (m:execute 'submit-answer)
    ;; skip the feedback quickly
    (m:execute 'feedback-timeout)))

(defun test-execution ()
  "Run through the entire execution session."
  (m:start-session 1 "Day 2 Execution")
  (m:execute 'add-click-message)
  (m:execute 'onward)
  (dotimes (blk 8)
    (m:execute 'onward) ; block start message
    (m:execute 'count-pulses) ; sync-pulse
    (m:execute 'onward) ; fixation
    (skip-the-nback)
    (dotimes (p 8)
      (m:execute 'onward) ; fixation
      (execution-fill) ; problem
      (m:execute 'onward) ; fixation
      (skip-the-nback))
    (m:execute 'onward) ; fixation
    ))
